;;########################################################################
;; modelob1.lsp
;; define mv-model-object-proto inheriting from model-object-proto
;;   the purpose for this object is to provide a simpler calling 
;;   sequence for the isnew methods of the plugins
;; Copyright (c) 1991-2002  by Forrest W. Young
;;########################################################################



(defproto mv-model-object-proto '() () model-object-proto )

(defmeth mv-model-object-proto :isnew 
                   (tool-id data-obj title name dialog 
                                &optional (ok-types '(numeric)));fwy4.28
  (let ((data-list (send data-obj :active-data ok-types));fwy4.28
        (variables (send data-obj :active-variables ok-types));fwy4.28
        (types     (send data-obj :active-types ok-types));fwy4.28
        (labels    (send data-obj :active-labels))
        (freq      (send data-obj :freq))
        (data-type)
        (freq-way-names (send data-obj :freq-way-names))
        (array     (send data-obj :array))
        )
    (send self :data-object data-obj)
    (setf *show-info* nil)
    (call-next-method data-list variables types labels freq data-type
                      freq-way-names array tool-id data-obj title name
                      dialog ok-types )
   ; (send self :elapsed-time
   ;     (/ (- (get-internal-real-time) (send self :statobj-start-time))
   ;        internal-time-units-per-second))
   ; (send self :instance-info (format nil "~a" (select (date-time) 9)))
   ; (setf *show-info* t)
   ; (when (and (send self :iconify)
   ;            (not (equal "hidden" (send self :title))))
   ;       (send self :info))
    (send *model-menu* :enabled t)
    ))


(defmeth mv-model-object-proto :make-names (&optional name extension)
  (if name
      (send self :name name)
      (setf name (send self :name)))
  (unless name (fatal-message "undefined name"))
  (if extension
      (send self :extension extension)
      (setf extension (send self :extension)))
  (send self :proper-name (send self :make-proper-name))
  (send self :full-name (send self :proper-name))
  (send self :elipsis-name (elipsis-name (send self :proper-name)))
  )

  
(defmeth model-object-proto :make-object-id ()
  (format nil "#<Object: ~a, Type:~a>   #<Subject:~a, Type:~a>~%"
          (send self :full-name)
          (send self :vistatype)
          (send (send self :data-object) :full-name)
          (send (send self :data-object) :vistatype)))
    

(defmeth model-object-proto :subject-id  (&optional (stream *standard-output*))
  (send (send self :data-object) :object-id stream))


(defmeth model-object-proto :make-vistatype ()
  (let* ((type (send self :button-name)))
    (cond
      ((equal "matrix" (string-downcase (send self :data-type)))
       (format nil "Relational[~ax~a], ~a(~a ~a ~a)" 
               (send self :nobs) (send self :nvar)
               (string-capitalize (first (send self :shapes )))
               (send self :nvar) (send self :nvar) (send self :nmat)))
      ((send self :array)
       (format nil "~aMeth[~ax~a], Array~a"type (send self :nobs) (send self :nvar)(send self :array-dimensions)))
      (t
       (format nil "~aMeth[~ax~a]"type (send self :nobs) (send self :nvar))))))


(defmeth model-object-proto :make-proper-name ()
  (send self :proper-name
        (concatenate-version (strcat (send self :model-abbrev) 
                                     "!"
                                     (send (send self :data-object) :name))
                             (string-downcase (send self :model-abbrev)))))


(defmeth model-object-proto :print (&optional (stream *standard-output*))
  (format stream "~a" (send self :proper-name)))

(defmeth model-object-proto :info (&optional (stream *standard-output*) 
                                              &key (verbose nil) (subject nil))
  (cond
    ((or verbose *history*)
     (unless (equal (string-downcase (send self :name)) "hidden")
             (format stream "~%; ~a: Name:      ~a~%" 
                     (if subject "Subjct:" "Object") 
                     (send self :proper-name))
             (format stream   ";         StatObj:   ~a~%" (send self :vistatype))
             (format stream   ";         ProtoType: ~a~%" 
                     (string-capitalize (send self :slot-value 'proto-name)))
             (format stream   ";         Address:   ~d~%" (address-of self))
             (format stream   ";         Created:   ~a~%" 
                         (send self :slot-value 'instance-info))
             (format stream   ";         Elapsed:   ~,4d seconds~%" 
                     (fuzz (send self :elapsed-time) 3))))
    (t
     (format stream "; Model:  ~a; ~a; ~,3d seconds~%> " 
             (send self :proper-name)
             (send self :vistatype)
             (fuzz (send self :elapsed-time) 3))))
  t)
             

(defmeth mv-model-object-proto :about-this-model 
  (&optional string &key title (show t) location size (pop-out t))
"Args: &OPTIONAL STRING &KEY TITLE (SHOW t)
Creates *about-window* if it doesn't exist. Then shows the about information for the current model in *about-window*."
;dont use string

  (cond
    (string
     (when self (send self :about string))
     t)
    (t
     (when (not *about-window*)
           (setf *about-window* (initial-about-window)))
     (send *about-window* :flush-window)
     (send *about-window* :top-most t)
     (send *about-window* :scroll 0 0)
     (send *about-window* :title (format nil "~2%~a" (send self :title)))
     (send self :analysis-help nil *about-window* title)
     (send *about-window* :fit-window-to-text)
     (send *about-window* :show-window)
     *about-window*)
    ))




(defun show (&optional (sob @)) 
  (use sob)
  (cond
    ((equal "data"   (sob-type sob)) (browse-data))
    ((equal "diss"   (sob-type sob)) (browse-data))
    ((equal "dash"   (sob-type sob)) (edit-data))
    ((equal "model"  (sob-type sob)) (interpret-model))
    ((equal "analy"  (sob-type sob)) (about-this-analysis))
    ((equal "transf" (sob-type sob)) (about-this-transformation)))
  sob)

(defun see (&optional (sob @)) (use sob) (visualize))

(defun about (&optional (sob @)) 
  (use sob)
  (cond
    ((equal "data"   (sob-type sob)) (about-these-data))
    ((equal "diss"   (sob-type sob)) (about-these-data))
    ((equal "dash"   (sob-type sob)) (about-these-data))
    ((equal "transf" (sob-type sob)) (about-this-transformation)))
    ((equal "analy"  (sob-type sob)) (about-this-analysis))
    ((equal "model"  (sob-type sob)) (interpret-model))
  sob)

(defun report (&rest args) 
  (use @)
  (cond
    ((equal "data"   (sob-type @)) (summary))
    ((equal "diss"   (sob-type @)) (summary))
    ((equal "dash"   (sob-type @)) (list-data))
    ((equal "model"  (sob-type @)) (report-model :dialog nil)))
  @)
